home *** CD-ROM | disk | FTP | other *** search
/ Linux Cubed Series 3: Developer Tools / Linux Cubed Series 3 - Developer Tools.iso / devel / lang / lisp / stk-3.0-b / stk-3 / blt-for-STk-3.0 / Demos / barchart.stk next >
Encoding:
Text File  |  1995-12-26  |  4.7 KB  |  156 lines
  1. (set! *load-path* (cons ".." *load-path*))
  2. (require "blt")
  3.  
  4. (define global list)    ; Kludge
  5.  
  6. ;;;;
  7. ;;;; Bitmap definitions
  8. ;;;;
  9. (blt_bitmap 'define 'pattern1 "((4 4) (01 02 04 08))")
  10. (blt_bitmap 'define 'pattern2 "((4 4) (08 04 02 01))")
  11. (blt_bitmap 'define 'pattern3 "((2 2) (01 02 ))")
  12. (blt_bitmap 'define 'pattern4 "((4 4) (0f 00 00 00))")
  13. (blt_bitmap 'define 'pattern5 "((4 4) (01 01 01 01))")
  14. (blt_bitmap 'define 'pattern6 "((2 2) (01 00 ))")
  15. (blt_bitmap 'define 'pattern7 "((4 4) (0f 01 01 01))")
  16. (blt_bitmap 'define 'pattern8 "((8 8) (ff 00 ff 00 ff 00 ff 00 ))")
  17. (blt_bitmap 'define 'pattern9 "((4 4) (03 03 0c 0c))")
  18. (blt_bitmap 'define 'hobbes   "((25 25) (
  19.    00 00 00 00 00 00 00 00 00 c0 03 00 78 e0 07 00 fc f8 07 00 cc 07 04 00
  20.    0c f0 0b 00 7c 1c 06 00 38 00 00 00 e0 03 10 00 e0 41 11 00 20 40 11 00
  21.    e0 07 10 00 e0 c1 17 00 10 e0 2f 00 20 e0 6f 00 18 e0 2f 00 20 c6 67 00
  22.    18 84 2b 00 20 08 64 00 70 f0 13 00 80 01 08 00 00 fe 07 00 00 00 00 00
  23.    00 00 00 00 ))")
  24.  
  25. ;;;;
  26. ;;;; Default Colors
  27. ;;;;
  28. (option 'add "*Blt_htext.Font"         "*Times-Bold-R*14*")
  29. (option 'add "*graph.xTitle"         "X Axis Label")
  30. (option 'add "*graph.yTitle"         "Y Axis Label")
  31. (option 'add "*graph.title"         "A Simple Barchart")
  32. (option 'add "*graph.xFont"         "*Times-Medium-R*12*")
  33. (option 'add "*graph.elemBackground"    "white")
  34. (option 'add "*graph.elemRelief"     "raised")
  35.  
  36. (define visual (winfo 'screenvisual *root*))
  37. (unless (or (eq? visual 'staticgray) (eq? visual 'grayscale))
  38.     (option 'add "*print.background" "yellow")
  39.     (option 'add "*quit.background"  "red"))
  40.  
  41. (define (print-ps)
  42.   (.graph 'postscript "bar.ps"
  43.       :pagewidth '6.5i
  44.       :pageheight '9i
  45.       :landscape #t))
  46.  
  47. ;;;;
  48. ;;;; Header hypertext
  49. ;;;;
  50. (blt_htext '.header :text "This is an example of the blt_barchart widget. The barchart has many components; 
  51. x and y axis, legend, crosshairs, elements, etc.
  52. To create a postscript file \"bar.ps\", press the %%BEGIN
  53. (button '.header.print     :text \"Print\"    :command  print-ps)
  54. (.header 'append .header.print)
  55. %% button.")
  56.  
  57. ;;;;" 
  58. ;;;; The barchart
  59. ;;;;
  60. (blt_barchart '.graph)
  61. (.graph 'xaxis 'configure :rotate 90 :command "FormatLabel")
  62.  
  63.  
  64. ;;;;
  65. ;;;; Footer hypertext
  66. ;;;;
  67.  
  68. (blt_htext '.footer :text "Hit the %%BEGIN
  69. (button '.footer.quit :text \"quit\" :command (lambda ()(destroy *root*)))
  70. (.footer 'append .footer.quit)
  71. %% button when you've seen enough.%%BEGIN
  72. (label '.footer.logo :bitmap '|BLT|)
  73. (.footer 'append .footer.logo :padx 20)
  74. %%")
  75.  
  76. ;;;;"
  77. ;;;; Callbacks  
  78. ;;;;
  79. (define (TurnOnHairs graph)
  80.   (bind graph "<Any-Motion>" '(|%W| 'crosshairs 'configure :position "@%x,%y")))
  81.  
  82. (define (TurnOffHairs graph)
  83.   (bind graph "<Any-Motion>" '(|%W| 'crosshairs 'configure :position "@%x,%y")))
  84.  
  85. (bind .graph "<Enter>" '(TurnOnHairs |%W|))
  86. (bind .graph "<Leave>" '(TurnOffHairs |%W|))
  87.  
  88. (define (FormatLabel w value)
  89.   ;; Determine the element name from the value
  90.   (let ((displaylist (w 'element 'show))
  91.      (index      (1- (inexact->exact (floor value)))))
  92.     (list-ref displaylist index)))
  93.  
  94.  
  95. (define names         '(One Two Three Four Five Six Seven Eight ))
  96. (define fgcolors     '(red green blue purple orange brown cyan navy))
  97. (define bgcolors    '(green blue purple orange brown cyan navy red))
  98. (define numColors    (length names))
  99.  
  100. (when (or (eq? visual 'staticgray) (eq? visual 'grayscale))
  101.       (set! fgcolors '(white white white white white white white white ))
  102.       (set! bgcolors '(black black black black black black black black )))
  103.  
  104.  
  105. (do ((i 0 (+ i 1)))
  106.     ((= i numColors))
  107.   (.graph 'element 'create (list-ref names i)
  108.      :data (format #f "~A ~A" (+ i 1) (+ i 1))
  109.      :fg (list-ref fgcolors i)
  110.      :bg (list-ref bgcolors i)
  111.      :stipple (format #f "pattern~A" (+ i 1))
  112.      :relief "raised"
  113.      :bd 2))
  114.  
  115. (.graph 'element 'create 'Nine    :data "9 -0.5" :fg "red" :relief "sunken")
  116. (.graph 'element 'create 'Ten    :data "10 2" :fg "seagreen" :stipple "hobbes"
  117.     :background "palegreen")
  118.  
  119. (.graph 'element 'create 'Eleven :data "11 3.3" :fg "blue")
  120.  
  121. (pack .header :padx 20 :pady 10)
  122. (pack .graph )
  123. (pack .footer :padx 20 :pady 10)
  124.     
  125. (wm 'min *root* 0 0)
  126.  
  127. ;;;;
  128. ;;;; Bindings
  129. ;;;;
  130.  
  131. (define info "")
  132.  
  133. (bind .graph "<B1-ButtonRelease>" (lambda (|W|)
  134.                     (|W| 'crosshairs 'toggle)))
  135. (bind .graph "<ButtonPress-3>"    (lambda (|W| x y)
  136.                     (let ((info (|W| 'element 'closest x y)))
  137.                       (if (null? info)
  138.                       (blt_bell)
  139.                       (format #t "~A\n" info)))))
  140.     
  141. (define (TurnOnHairs graph)
  142.   (bind graph "<Any-Motion>"  (lambda (|W| x y)
  143.                 (|W| 'crosshairs 'configure 
  144.                      :position (format #f "@~A,~A" x y)))))
  145.  
  146. (define (TurnOffHairs graph)
  147.   (bind graph "<Any-Motion>" (lambda (|W| x y)
  148.                    (|W| 'crosshairs 'configure 
  149.                     :position (format #f "@~A,~A" x y)))))
  150.  
  151. (bind .graph "<Enter>" (lambda (|W|) (TurnOnHairs |W|)))
  152. (bind .graph "<Leave>" (lambda (|W|) (TurnOnHairs |W|)))
  153.  
  154. ;;;;
  155. ;;;; FEATURES.TCL has not been rewritten for STk. If someone can do it....
  156. ;;;;